perm filename SETLET.F4[MSS,LCS] blob
sn#128715 filedate 1974-11-04 generic text, type T, neo UTF8
00100 C******** SUBRS. SETLET, SETNUM, ACSHFT *********
00200
00300 SUBROUTINE SETLET
00400 DIMENSION R(8,100)
00500 COMMON/SCM/V(78),Y,LCNT,STAFF,JLIST(200),REND
00600 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(14),M,K,J,X,A,B
00650 1 /FLM/RPOS(2,300) /PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(4000)
00800 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
00900 EQUIVALENCE (JF,JQ(4)),(R,RN(3001))
01000 M=1
01100 RPOS(1,1)=0
01200 DO 1 K=1,ITEM
01300 IF(FINDIT(K))GO TO 1
01400 C SKIPS NON-NOTES AND WRONG STAFF
01500 M=M+1
01600 RPOS(1,M)=RN(L+2)
01700 CC RPOS(2,M)=L
01800 1 CONTINUE
01900 CALL SETNUM
02000 CALL SORT2(RPOS,M)
02100 K=2
02200 22 IF(RPOS(1,K).NE.RPOS(1,K-1))GO TO 2
02300 M=M-1
02400 DO 20 J=K,M
02500 20 RPOS(1,J)=RPOS(1,J+1)
02600 C DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
02700 GO TO 22
02800 2 K=K+1
02900 IF(K.LT.M)GO TO 22
03000 DO 4 K=2,M
03100 JB=RHORZ(RPOS(1,K))
03200 CALL NOTWRT
03300 JF=JF+1
03400 4 IF(JF.EQ.10)JF=0
03500 CALL DPYOUT(3)
03600 CALL SETPOG(1)
03700 RPOS(1,M+1)=200
03800 J=1
03900 CALL TYPE
04000 REREAD F78F,V
04100 X=V(J)+1
04200 M=1
04300 3 K=X
04400 A=RPOS(1,K)
04500 B=RPOS(1,K+1)
04600 R(2,M)=A+(B-A)*(X-K)
04700 IF(R(4,M).NE.0)GO TO 5
04800 R(4,M)=V(J+1)
04900 J=J+2
05000 GO TO 6
05100 C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
05200 C TYPE Nn, Vert pos/Nn, Vert pos/ OR Nn/Nn/ (if P4≠0)
05300 5 J=J+1
05400 6 M=M+1
05500 X=V(J)+1
05600 IF(X.GT.1)GO TO 3
05700 C CAN'T PUT LETTER AT POS. 0 *********
05800 END
05900
06000 SUBROUTINE SETNUM
06100 DIMENSION SU(320)
06200 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
06300 COMMON/POSI/STF(8),JJB,POS/DPY/ST(4000),WDS(250),MEDIT,IGO
06400 EQUIVALENCE (JC,JQ(1)),(JF,JQ(4)),(RJE,RJQ(3)),(RJD,RJQ(2))
06500 1,(SU(1),ST(3600))
06600 CALL DPYSET(3,SU,320)
06700 CALL DPYBRT(6)
06800 JF=1
06900 CC RA=ST(1)
07000 CC RJD=R(3,1)
07100 POS=STF(JC+4)
07200 RJD=18.
07300 JA=5
07400 RJE=1
07500 END
07600
07700 SUBROUTINE ACSHFT(RX)
07800 COMMON /XRN/RN(4000)
07900 COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA
08000 1,DBST,NFLG,IXX,ISEMI,IQT,F(50),IAMP,K,KN,M,MODE,IBLA
08100 DIMENSION R(8,100)
08200 EQUIVALENCE (R,RN(3001)),(A,F(1)),(B,F(2)),(X,F(4)),
08300 1(Y,F(5)),(Z,F(6)),(JD,F(7)),(RN1,F(8)),(RH,F(9))
08400 Z=0
08500 L=K-1
08600 M=L-ABS(RX)
08700 JD=1
08800 RN1=99
08900 Y=-.23
09000 IF(RX.LT.0)GO TO 1
09100 L=M
09200 M=K-1
09300 JD=-1
09400 1 DO 2 N=M,L,JD
09500 C DOES IT HAVE AN ACCID?
09600 IF(AMOD(R(5,N),10.).EQ.0)GO TO 2
09700 A=R(6,N+1)
09800 B=R(6,N-1)
09900 IF(RN1.NE.99)GO TO 3
10000 C IS THIS THE FIRST ACCID?
10100 RN1=R(4,N)
10200 GO TO 6
10300 3 RH=R(4,N)
10400 IF(ABS(RH-RN1).LT.5)GO TO 4
10500 RN1=RH
10600 IF(Y.GT.0)Z=Z+.04
10700 C STOPS OCT., ETC. ACCIS BEING MOVED TO LEFT.
10800 Y=-.23+Z
10900 6 IF(A.EQ.20.OR.B.EQ.20)Y=Z
11000 4 X=0
11100 IF(R(6,N).EQ.20)X=-.24
11200 IF(R(6,N).EQ.10)X=.24
11300 Y=Y+.23
11400 IF(X+Y.LT.1)GO TO 7
11500 RN1=RH
11600 Z=Z+.04
11700 Y=0
11800 IF(A.EQ.20.OR.B.EQ.20)Y=.23
11900 C SO Y DOESN'T GET >1.
12000 Y=Y+Z
12100 7 X=X+Y
12200 IF(ABS(X-.04).LT..01)X=0
12300 IF(X.GE.0)GO TO 5
12400 Y=.23+Z
12500 X=Z
12600 5 R(5,N)=R(5,N)+X
12700 2 CONTINUE
12800 END